home *** CD-ROM | disk | FTP | other *** search
Oberon Text | 1994-07-11 | 34.7 KB | 859 lines | [.Ob./.Ob4] |
- Syntax10b.Scn.Fnt
- Syntax10.Scn.Fnt
- Syntax10i.Scn.Fnt
- Courier10.Scn.Fnt
- MODULE POPT; (* NW, RC 6.3.89 / 9.2.94 *)
- IMPORT
- OPS := POPS, OPM := POPM;
- CONST
- MaxConstLen* = OPS.MaxStrLen;
- TYPE
- Const* = POINTER TO ConstDesc;
- Object* = POINTER TO ObjDesc;
- Struct* = POINTER TO StrDesc;
- Node* = POINTER TO NodeDesc;
- ConstExt* = POINTER TO OPS.String;
- ConstDesc* = RECORD
- ext*: ConstExt; (* string or code for code proc *)
- intval*: LONGINT; (* constant value or adr, proc par size, text position or least case label *)
- intval2*: LONGINT; (* string length, proc var size or larger case label *)
- setval*: SET; (* constant value, procedure body present or "ELSE" present in case *)
- realval*: LONGREAL (* real or longreal constant value *)
- END ;
- ObjDesc* = RECORD
- left*, right*, link*, scope*: Object;
- name*: OPS.Name;
- leaf*: BOOLEAN;
- mode*, mnolev*: SHORTINT; (* mnolev < 0 -> mno = -mnolev *)
- vis*: SHORTINT; (* 0: internal; 1: external; 2: externalR *)
- typ*: Struct;
- conval*: Const;
- adr*, linkadr*: LONGINT
- END ;
- StrDesc* = RECORD
- form*, comp*, mno*, extlev*: SHORTINT;
- ref*, sysflag*: INTEGER;
- n*, size*, tdadr*, offset*, txtpos*: LONGINT;
- BaseTyp*: Struct;
- link*, strobj*: Object
- END ;
- NodeDesc* = RECORD
- left*, right*, link*: Node;
- class*, subcl*: SHORTINT;
- readonly*: BOOLEAN;
- typ*: Struct;
- obj*: Object;
- conval*: Const
- END ;
- (* Objects:
- mode | adr conval link scope leaf
- ---------------------------------------------
- Undef | Not used
- Var | adr next regopt Glob or loc var or proc value parameter
- VarPar| vadr next regopt Procedure var parameter
- Con | val Constant
- Fld | off next Record field
- Typ | Named type
- LProc | sizes firstpar scope leaf Local procedure
- XProc | pno sizes firstpar scope leaf External procedure
- SProc | fno sizes Standard procedure
- CProc | code firstpar scope Code procedure
- IProc | pno sizes scope leaf Interrupt procedure
- Mod | key scope Module
- Head | txtpos owner firstvar Scope anchor
- TProc | index sizes firstpar scope leaf Bound procedure, index = 10000H*mthno+pno
-
- Structures:
- form comp | n BaseTyp link mno tdadr offset txtpos sysflag
- -----------------------------------------------------------------------------
- Undef Basic |
- Byte Basic |
- Bool Basic |
- Char Basic |
- SInt Basic |
- Int Basic |
- LInt Basic |
- Real Basic |
- LReal Basic |
- Set Basic |
- String Basic |
- NilTyp Basic |
- NoTyp Basic |
- Pointer Basic | PBaseTyp mno txtpos sysflag
- ProcTyp Basic | ResTyp params mno txtpos sysflag
- Comp Array | nofel ElemTyp mno txtpos sysflag
- Comp DynArr| dim ElemTyp mno lenoff txtpos sysflag
- Comp Record| nofmth RBaseTyp fields mno tdadr txtpos sysflag
- Nodes:
- design = Nvar|Nvarpar|Nfield|Nderef|Nindex|Nguard|Neguard|Ntype|Nproc.
- expr = design|Nconst|Nupto|Nmop|Ndop|Ncall.
- nextexpr = NIL|expr.
- ifstat = NIL|Nif.
- casestat = Ncaselse.
- sglcase = NIL|Ncasedo.
- stat = NIL|Ninittd|Nenter|Nassign|Ncall|Nifelse|Ncase|Nwhile|Nrepeat|
- Nloop|Nexit|Nreturn|Nwith|Ntrap.
- class subcl obj left right link
- ---------------------------------------------------------
- design Nvar var nextexpr
- Nvarpar varpar nextexpr
- Nfield field design nextexpr
- Nderef design nextexpr
- Nindex design expr nextexpr
- Nguard design nextexpr (typ = guard type)
- Neguard design nextexpr (typ = guard type)
- Ntype type nextexpr
- Nproc normal proc nextexpr
- super proc nextexpr
- expr design
- Nconst const (val = node^.conval)
- Nupto expr expr nextexpr
- Nmop not expr nextexpr
- minus expr nextexpr
- is tsttype expr nextexpr
- conv expr nextexpr
- abs expr nextexpr
- cap expr nextexpr
- odd expr nextexpr
- adr expr nextexpr SYSTEM.ADR
- cc Nconst nextexpr SYSTEM.CC
- val expr nextexpr SYSTEM.VAL
- Ndop times expr expr nextexpr
- slash expr expr nextexpr
- div expr expr nextexpr
- mod expr expr nextexpr
- and expr expr nextexpr
- plus expr expr nextexpr
- minus expr expr nextexpr
- or expr expr nextexpr
- eql expr expr nextexpr
- neq expr expr nextexpr
- lss expr expr nextexpr
- leq expr expr nextexpr
- grt expr expr nextexpr
- geq expr expr nextexpr
- in expr expr nextexpr
- ash expr expr nextexpr
- msk expr Nconst nextexpr
- len design Nconst nextexpr
- bit expr expr nextexpr SYSTEM.BIT
- lsh expr expr nextexpr SYSTEM.LSH
- rot expr expr nextexpr SYSTEM.ROT
- Ncall fpar design nextexpr nextexpr
- nextexpr NIL
- expr
- ifstat NIL
- Nif expr stat ifstat
- casestat Ncaselse sglcase stat (minmax = node^.conval)
- sglcase NIL
- Ncasedo Nconst stat sglcase
- stat NIL
- Ninittd stat (of node^.typ)
- Nenter proc stat stat stat (proc=NIL for mod)
- Nassign assign design expr stat
- newfn design stat
- incfn design expr stat
- decfn design expr stat
- inclfn design expr stat
- exclfn design expr stat
- copyfn design expr stat
- getfn design expr stat SYSTEM.GET
- putfn expr expr stat SYSTEM.PUT
- getrfn design Nconst stat SYSTEM.GETREG
- putrfn Nconst expr stat SYSTEM.PUTREG
- sysnewfn design expr stat SYSTEM.NEW
- movefn expr expr stat SYSTEM.MOVE
- (right^.link = 3rd par)
- Ncall fpar design nextexpr stat
- Nifelse ifstat stat stat
- Ncase expr casestat stat
- Nwhile expr stat stat
- Nrepeat stat expr stat
- Nloop stat stat
- Nexit stat
- Nreturn proc nextexpr stat (proc = NIL for mod)
- Nwith ifstat stat stat
- Ntrap expr stat
- CONST
- maxImps = 31; (* must be < 128 *)
- topScope*: Object;
- undftyp*, bytetyp*, booltyp*, chartyp*, sinttyp*, inttyp*, linttyp*,
- realtyp*, lrltyp*, settyp*, stringtyp*, niltyp*, notyp*, sysptrtyp*: Struct;
- nofGmod*: SHORTINT; (*nof imports*)
- GlbMod*: ARRAY maxImps OF Object; (* GlbMod[i]^.mode = exported module number *)
- SYSimported*: BOOLEAN;
- CONST
- (* object modes *)
- Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
- SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
- (* structure forms *)
- Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
- Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
- Pointer = 13; ProcTyp = 14; Comp = 15;
- (* composite structure forms *)
- Basic = 1; Array = 2; DynArr = 3; Record = 4;
- (*function number*)
- assign = 0;
- haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4;
- entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9;
- shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14;
- inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32;
- (*SYSTEM function number*)
- adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23;
- getfn = 24; putfn = 25; getrfn = 26; putrfn = 27;
- bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31;
- (* module visibility of objects *)
- internal = 0; external = 1; externalR = 2;
- firstStr = 16;
- maxStruct = OPM.MaxStruct; (* must be < 256 *)
- maxUndPtr = 64;
- NotYetExp = 0;
- universe, syslink: Object;
- strno, udpinx: INTEGER;
- nofExp: SHORTINT;
- nofhdfld: LONGINT;
- undPtr: ARRAY maxUndPtr OF Struct;
- PROCEDURE Init*;
- BEGIN topScope := universe; strno := 0; udpinx := 0; nofGmod := 0; SYSimported := FALSE
- END Init;
- PROCEDURE Close*;
- VAR i: INTEGER;
- BEGIN i := 0;
- WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END (* garbage collection *)
- END Close;
- PROCEDURE err(n: INTEGER);
- BEGIN OPM.err(n)
- END err;
- PROCEDURE NewConst*(): Const;
- VAR const: Const;
- BEGIN NEW(const); (*const^.ext := NIL;*) RETURN const
- END NewConst;
- PROCEDURE NewObj*(): Object;
- VAR obj: Object;
- BEGIN NEW(obj); (*obj^.left := NIL; obj^.right := NIL; obj^.link := NIL; obj^.scope := NIL; *)
- (*obj^.typ := NIL; obj^.conval := NIL;*) RETURN obj
- END NewObj;
- PROCEDURE NewStr*(form, comp: SHORTINT): Struct;
- VAR typ: Struct;
- BEGIN NEW(typ); (*typ^.link := NIL; typ^.strobj := NIL;*)
- typ^.form := form; typ^.comp := comp;
- (*typ^.mno := 0; typ^.ref := 0; typ^.sysflag := 0; typ^.extlev := 0; typ^.n := 0;*)
- typ^.tdadr := OPM.TDAdrUndef; typ^.offset := OPM.TDAdrUndef;
- typ^.txtpos := OPM.errpos; typ^.size := -1; typ^.BaseTyp := undftyp; RETURN typ
- END NewStr;
- PROCEDURE NewNode*(class: SHORTINT): Node;
- VAR node: Node;
- BEGIN
- NEW(node); node^.class := class; (*node^.left := NIL; node^.right := NIL; node^.link := NIL;*)
- (*node^.typ := NIL; node^.obj := NIL; node^.conval := NIL;*)
- RETURN node
- END NewNode;
- PROCEDURE NewExt*(): ConstExt;
- VAR ext: ConstExt;
- BEGIN NEW(ext); RETURN ext
- END NewExt;
- PROCEDURE FindImport*(mod: Object; VAR res: Object);
- VAR obj: Object;
- BEGIN obj := mod^.scope;
- LOOP
- IF obj = NIL THEN EXIT END ;
- IF OPS.name < obj^.name THEN obj := obj^.left
- ELSIF OPS.name > obj^.name THEN obj := obj^.right
- ELSE (*found*)
- IF (obj^.mode = Typ) & (obj^.vis = internal) THEN obj := NIL END ;
- EXIT
- END
- END ;
- res := obj
- END FindImport;
- PROCEDURE Find*(VAR res: Object);
- VAR obj, head: Object;
- BEGIN head := topScope;
- LOOP obj := head^.right;
- LOOP
- IF obj = NIL THEN EXIT END ;
- IF OPS.name < obj^.name THEN obj := obj^.left
- ELSIF OPS.name > obj^.name THEN obj := obj^.right
- ELSE (*found*) EXIT
- END
- END ;
- IF obj # NIL THEN EXIT END ;
- head := head^.left;
- IF head = NIL THEN EXIT END
- END ;
- res := obj
- END Find;
- PROCEDURE FindField*(VAR name: OPS.Name; typ: Struct; VAR res: Object);
- VAR obj: Object;
- BEGIN
- WHILE typ # NIL DO obj := typ^.link;
- WHILE obj # NIL DO
- IF name < obj^.name THEN obj := obj^.left
- ELSIF name > obj^.name THEN obj := obj^.right
- ELSE (*found*) res := obj; RETURN
- END
- END ;
- typ := typ^.BaseTyp
- END ;
- res := NIL
- END FindField;
- PROCEDURE Insert*(VAR name: OPS.Name; VAR obj: Object);
- VAR ob0, ob1: Object; left: BOOLEAN;
- BEGIN ob0 := topScope; ob1 := ob0^.right; left := FALSE;
- LOOP
- IF ob1 # NIL THEN
- IF name < ob1^.name THEN ob0 := ob1; ob1 := ob0^.left; left := TRUE
- ELSIF name > ob1^.name THEN ob0 := ob1; ob1 := ob0^.right; left := FALSE
- ELSE (*double def*) err(1); ob0 := ob1; ob1 := ob0^.right
- END
- ELSE (*insert*) ob1 := NewObj(); ob1^.leaf := TRUE;
- IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END ;
- ob1^.left := NIL; ob1^.right := NIL; COPY(name, ob1^.name);
- ob1^.mnolev := topScope^.mnolev; EXIT
- END
- END ;
- obj := ob1
- END Insert;
- PROCEDURE OpenScope*(level: SHORTINT; owner: Object);
- VAR head: Object;
- BEGIN head := NewObj();
- head^.mode := Head; head^.mnolev := level; head^.link := owner;
- IF owner # NIL THEN owner^.scope := head END ;
- head^.left := topScope; head^.right := NIL; head^.scope := NIL; topScope := head
- END OpenScope;
- PROCEDURE CloseScope*;
- BEGIN topScope := topScope^.left
- END CloseScope;
- PROCEDURE InsertImport(obj, root: Object; VAR old: Object);
- VAR ob0, ob1: Object; left: BOOLEAN;
- BEGIN ob0 := root; ob1 := ob0^.right; left := FALSE;
- LOOP
- IF ob1 # NIL THEN
- IF obj^.name < ob1^.name THEN ob0 := ob1; ob1 := ob1^.left; left := TRUE
- ELSIF obj^.name > ob1^.name THEN ob0 := ob1; ob1 := ob1^.right; left := FALSE
- ELSE old := ob1; EXIT
- END
- ELSE ob1 := obj;
- IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END ;
- ob1^.left := NIL; ob1^.right := NIL; ob1^.mnolev := root^.mnolev; old := NIL; EXIT
- END
- END
- END InsertImport;
- PROCEDURE ReadId(VAR name: ARRAY OF CHAR; VAR len: LONGINT);
- VAR i: INTEGER; ch: CHAR;
- BEGIN i := 0;
- REPEAT
- OPM.SymRCh(ch); name[i] := ch; INC(i)
- UNTIL ch = 0X;
- len := i
- END ReadId;
- PROCEDURE WriteId(VAR name: ARRAY OF CHAR);
- VAR i: INTEGER; ch: CHAR;
- BEGIN i := 0;
- REPEAT ch := name[i]; OPM.SymWCh(ch); INC(i)
- UNTIL ch = 0X
- END WriteId;
- PROCEDURE Import*(VAR aliasName, impName, selfName: OPS.Name);
- VAR i, m, s, class: INTEGER;
- k, len: LONGINT; rval: REAL;
- ch: CHAR; done: BOOLEAN;
- nofLmod, strno, parlev, fldlev: INTEGER;
- obj, head, old: Object;
- typ: Struct;
- ext: ConstExt;
- mname: OPS.Name;
- LocMod: ARRAY maxImps + 1 OF Object;
- struct: ARRAY maxStruct OF Struct;
- param, lastpar, fldlist, lastfld: ARRAY 6 OF Object;
- PROCEDURE reverseList(p: Object; mnolev: SHORTINT);
- VAR q, r: Object;
- BEGIN q := NIL;
- WHILE p # NIL DO p^.mnolev := mnolev;
- r := p^.link; p^.link := q; q := p; p := r
- END
- END reverseList;
- BEGIN nofLmod := 0; strno := firstStr;
- parlev := -1; fldlev := -1;
- IF impName = "SYSTEM" THEN SYSimported := TRUE;
- Insert(aliasName, obj); obj^.mode := Mod; obj^.mnolev := 0; obj^.scope := syslink;
- obj^.adr := 0; obj^.typ := notyp
- ELSE OPM.OldSym(impName, FALSE, done);
- IF done THEN
- struct[Undef] := undftyp; struct[Byte] := bytetyp;
- struct[Bool] := booltyp; struct[Char] := chartyp;
- struct[SInt] := sinttyp; struct[Int] := inttyp;
- struct[LInt] := linttyp; struct[Real] := realtyp;
- struct[LReal] := lrltyp; struct[Set] := settyp;
- struct[String] := stringtyp; struct[NilTyp] := niltyp;
- struct[NoTyp] := notyp;
- struct[Pointer] := sysptrtyp;
- NEW(head); (*for bound procedures*)
- LOOP (*read next item from symbol file*)
- OPM.SymRTag(class);
- IF OPM.eofSF() THEN EXIT END ;
- IF (class < 8) OR (class = 23) OR (class = 25) THEN (*object*)
- obj := NewObj(); m := 0;
- OPM.SymRTag(s); obj^.typ := struct[s];
- CASE class OF
- 1:
- obj^.mode := Con; obj^.conval := NewConst();
- CASE obj^.typ^.form OF
- Byte, Char:
- OPM.SymRCh(ch); obj^.conval^.intval := ORD(ch)
- | SInt, Bool:
- OPM.SymRCh(ch); i := ORD(ch);
- IF i > OPM.MaxSInt THEN i := i + 2*OPM.MinSInt END ;
- obj^.conval^.intval := i
- | Int:
- OPM.SymRInt(obj^.conval^.intval)
- | LInt:
- OPM.SymRLInt(obj^.conval^.intval)
- | Set:
- OPM.SymRSet(obj^.conval^.setval)
- | Real:
- OPM.SymRReal(rval); obj^.conval^.realval := rval;
- obj^.conval^.intval := OPM.ConstNotAlloc
- | LReal:
- OPM.SymRLReal(obj^.conval^.realval);
- obj^.conval^.intval := OPM.ConstNotAlloc
- | String:
- obj^.conval^.ext := NewExt();
- ReadId(obj^.conval^.ext^, obj^.conval^.intval2);
- obj^.conval^.intval := OPM.ConstNotAlloc
- | NilTyp:
- obj^.conval^.intval := OPM.nilval
- END
- | 2, 3:
- obj^.mode := Typ; OPM.SymRTag(m);
- IF obj^.typ^.strobj = NIL THEN obj^.typ^.strobj := obj END ;
- IF class = 2 THEN obj^.vis := external ELSE obj^.vis := internal END
- | 4, 23:
- obj^.mode := Var;
- IF OPM.ExpVarAdr THEN OPM.SymRLInt(obj^.adr)
- ELSE OPM.SymRTag(s); obj^.adr := s
- END ;
- IF class = 23 THEN obj^.vis := externalR ELSE obj^.vis := external END
- | 5, 6, 7, 25:
- obj^.conval := NewConst();
- IF class = 5 THEN obj^.mode := IProc; OPM.SymRTag(s); obj^.adr := s
- ELSIF class = 6 THEN obj^.mode := XProc; OPM.SymRTag(s); obj^.adr := s
- ELSIF class = 7 THEN obj^.mode := CProc; ext := NewExt(); obj^.conval^.ext := ext;
- OPM.SymRCh(ch); s := ORD(ch); ext^[0] := ch; i := 1; obj^.adr := 0;
- WHILE i <= s DO OPM.SymRCh(ext^[i]); INC(i) END
- ELSE obj^.mode := TProc; obj^.vis := external; OPM.SymRTag(s); typ := struct[s];
- OPM.SymRTag(i); OPM.SymRTag(s); obj^.adr := 10000H*i + s
- END ;
- obj^.linkadr := OPM.LANotAlloc; (* link adr *)
- obj^.conval^.intval := -1;
- reverseList(lastpar[parlev], LocMod[0]^.mnolev);
- obj^.link := param[parlev]^.right; DEC(parlev)
- END ;
- ReadId(obj^.name, len);
- IF class = 25 THEN
- head^.right := typ^.link; head^.mnolev := -typ^.mno; InsertImport(obj, head, old); typ^.link := head^.right
- ELSE InsertImport(obj, LocMod[m], old)
- END ;
- IF (old # NIL) & (obj^.mode = Typ) THEN struct[s] := old^.typ END
- ELSIF class < 13 THEN (*structure*)
- typ := NewStr(Undef, Basic); OPM.SymRTag(s); typ^.BaseTyp := struct[s];
- OPM.SymRTag(s); typ^.mno := -LocMod[s]^.mnolev;
- CASE class OF
- 8:
- typ^.form := Pointer; typ^.size := OPM.PointerSize; typ^.n := 0
- | 9:
- typ^.form := ProcTyp; typ^.size := OPM.ProcSize;
- reverseList(lastpar[parlev], -typ^.mno);
- typ^.link := param[parlev]^.right; DEC(parlev)
- | 10:
- typ^.form := Comp; typ^.comp := Array; OPM.SymRLInt(typ^.size);
- typ^.n := typ^.size DIV typ^.BaseTyp^.size
- | 11:
- typ^.form := Comp; typ^.comp := DynArr;
- OPM.SymRLInt(typ^.size); OPM.SymRInt(typ^.offset);
- IF typ^.BaseTyp^.comp = DynArr THEN typ^.n := typ^.BaseTyp^.n + 1
- ELSE typ^.n := 0
- END
- | 12:
- typ^.form := Comp; typ^.comp := Record;
- OPM.SymRLInt(typ^.size); typ^.n := 0;
- reverseList(lastfld[fldlev], -typ^.mno); typ^.link := fldlist[fldlev]^.right; DEC(fldlev);
- IF typ^.BaseTyp = notyp THEN typ^.BaseTyp := NIL; typ^.extlev := 0
- ELSE typ^.extlev := typ^.BaseTyp^.extlev + 1
- END ;
- OPM.SymRInt(typ^.tdadr)
- END ;
- struct[strno] := typ; INC(strno)
- ELSIF class = 13 THEN (*parameter list start*)
- obj := NewObj(); obj^.mode := Head; obj^.right := NIL;
- IF parlev < 5 THEN INC(parlev); param[parlev] := obj; lastpar[parlev] := NIL
- ELSE err(229)
- END
- ELSIF class < 16 THEN (*parameter*)
- obj := NewObj();
- IF class = 14 THEN obj^.mode := Var ELSE obj^.mode := VarPar END ;
- OPM.SymRTag(s); obj^.typ := struct[s];
- IF OPM.ExpParAdr THEN OPM.SymRLInt(obj^.adr) END ;
- ReadId(obj^.name, len);
- obj^.link := lastpar[parlev]; lastpar[parlev] := obj;
- IF param[parlev]^.right = NIL THEN param[parlev]^.right := obj END
- ELSIF class = 16 THEN (*start field list*)
- obj := NewObj(); obj^.mode := Head; obj^.right := NIL;
- IF fldlev < 5 THEN INC(fldlev); fldlist[fldlev] := obj; lastfld[fldlev] := NIL
- ELSE err(229)
- END
- ELSIF (class = 17) OR (class = 24) THEN (*field*)
- obj := NewObj(); obj^.mode := Fld; OPM.SymRTag(s);
- obj^.typ := struct[s]; OPM.SymRLInt(obj^.adr);
- ReadId(obj^.name, len);
- obj^.link := lastfld[fldlev]; lastfld[fldlev] := obj;
- InsertImport(obj, fldlist[fldlev], old);
- IF class = 24 THEN obj^.vis := externalR ELSE obj^.vis := external END
- ELSIF (class = 18) OR (class = 19) THEN (*hidden pointer or proc*)
- obj := NewObj(); obj^.mode := Fld; OPM.SymRLInt(obj^.adr);
- IF class = 18 THEN obj^.name := OPM.HdPtrName
- ELSE obj^.name := OPM.HdProcName
- END ;
- obj^.typ := notyp; obj^.vis := internal;
- obj^.link := lastfld[fldlev]; lastfld[fldlev] := obj;
- IF fldlist[fldlev]^.right = NIL THEN
- fldlist[fldlev]^.right := obj
- END
- ELSIF class = 20 THEN (*fixup pointer typ*)
- OPM.SymRTag(s); typ := struct[s]; OPM.SymRTag(s);
- IF typ^.BaseTyp = undftyp THEN typ^.BaseTyp := struct[s] END
- ELSIF class = 21 THEN (*sysflag*)
- OPM.SymRTag(s); typ := struct[s]; OPM.SymRTag(s); typ^.sysflag := s
- ELSIF class = 22 THEN (*module anchor*)
- OPM.SymRLInt(k); ReadId(mname, len);
- IF mname = selfName THEN err(154) END ;
- i := 0;
- WHILE (i < nofGmod) & (mname # GlbMod[i]^.name) DO
- INC(i)
- END ;
- IF i < nofGmod THEN (*module already present*)
- IF k # GlbMod[i]^.adr THEN err(150) END ;
- obj := GlbMod[i]
- ELSE obj := NewObj();
- IF nofGmod < maxImps THEN GlbMod[nofGmod] := obj; INC(nofGmod)
- ELSE err(227)
- END ;
- obj^.mode := NotYetExp; COPY(mname, obj^.name);
- obj^.adr := k; obj^.mnolev := -nofGmod; obj^.right := NIL
- END ;
- IF nofLmod < maxImps + 1 THEN LocMod[nofLmod] := obj; INC(nofLmod)
- ELSE err(227)
- END
- ELSIF class = 26 THEN (*nof methods*)
- OPM.SymRTag(s); typ := struct[s]; OPM.SymRTag(s); typ^.n := s
- ELSIF class = 27 THEN (*hidden method*)
- obj := NewObj(); obj^.mode := TProc; obj^.name := OPM.HdTProcName; obj^.typ := undftyp;
- OPM.SymRTag(s); typ := struct[s]; obj^.mnolev := -typ^.mno;
- OPM.SymRTag(i); OPM.SymRTag(s); obj^.adr := 10000H*i + s;
- obj^.linkadr := OPM.LANotAlloc; obj^.vis := internal;
- obj^.link := NewObj(); obj^.link^.typ := typ; old := typ^.link;
- IF old = NIL THEN typ^.link := obj
- ELSE WHILE old^.left # NIL DO old := old^.left END ;
- old^.left := obj
- END
- END
- END (*LOOP*) ;
- Insert(aliasName, obj);
- obj^.mode := Mod; obj^.scope := LocMod[0]^.right;
- obj^.mnolev := LocMod[0]^.mnolev; obj^.typ := notyp;
- OPM.CloseOldSym
- END
- END
- END Import;
- PROCEDURE^ OutStr(typ: Struct);
- PROCEDURE^ OutObjs(obj: Object);
- PROCEDURE ^OutFlds(fld: Object; adr: LONGINT; visible: BOOLEAN);
- PROCEDURE OutPars(par: Object);
- BEGIN
- OPM.SymWTag(13);
- WHILE par # NIL DO
- OutStr(par^.typ);
- IF par^.mode = Var THEN OPM.SymWTag(14) ELSE OPM.SymWTag(15) END ;
- OPM.SymWTag(par^.typ^.ref);
- IF OPM.ExpParAdr THEN OPM.SymWLInt(par^.adr) END ;
- WriteId(par^.name); par := par^.link
- END
- END OutPars;
- PROCEDURE OutHdFld(typ: Struct; fld: Object; adr: LONGINT);
- VAR i, j, n: LONGINT; btyp: Struct;
- BEGIN
- IF typ^.comp = Record THEN OutFlds(typ^.link, adr, FALSE)
- ELSIF typ^.comp = Array THEN btyp := typ^.BaseTyp; n := typ^.n;
- WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ;
- IF (btyp^.form = Pointer) OR (btyp^.comp = Record) THEN
- j := nofhdfld; OutHdFld(btyp, fld, adr);
- IF j # nofhdfld THEN i := 1;
- WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO
- INC(adr, btyp^.size); OutHdFld(btyp, fld, adr); INC(i)
- END
- END
- END
- ELSIF OPM.ExpHdPtrFld & ((typ^.form = Pointer) OR (fld^.name = OPM.HdPtrName)) THEN
- OPM.SymWTag(18); OPM.SymWLInt(adr); INC(nofhdfld)
- ELSIF OPM.ExpHdProcFld & ((typ^.form = ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN
- OPM.SymWTag(19); OPM.SymWLInt(adr); INC(nofhdfld)
- END
- END OutHdFld;
- PROCEDURE OutFlds(fld: Object; adr: LONGINT; visible: BOOLEAN);
- BEGIN
- IF visible THEN OPM.SymWTag(16) END ;
- WHILE (fld # NIL) & (fld^.mode = Fld) DO
- IF (fld^.vis # internal) & visible THEN
- OutStr(fld^.typ);
- IF fld^.vis = external THEN OPM.SymWTag(17) ELSE OPM.SymWTag(24) END ;
- OPM.SymWTag(fld^.typ^.ref); OPM.SymWLInt(fld^.adr); WriteId(fld^.name)
- ELSE OutHdFld(fld^.typ, fld, fld^.adr + adr)
- END ;
- fld := fld^.link
- END
- END OutFlds;
- PROCEDURE OutStr(typ: Struct);
- VAR m, em, r: INTEGER; btyp: Struct; mod: Object;
- BEGIN
- IF typ^.ref < 0 THEN OPM.Mark(234, typ^.txtpos)
- ELSIF typ^.ref = 0 THEN
- typ^.ref := -1;
- m := typ^.mno; btyp := typ^.BaseTyp;
- IF m > 0 THEN mod := GlbMod[m-1]; em := mod^.mode;
- IF em = NotYetExp THEN
- mod^.mode := nofExp; m := nofExp; INC(nofExp);
- OPM.SymWTag(22); OPM.SymWLInt(mod^.adr); WriteId(mod^.name)
- ELSE m := em
- END
- END ;
- CASE typ^.form OF
- Undef .. NoTyp:
- | Pointer:
- OPM.SymWTag(8);
- IF btyp^.ref > 0 THEN OPM.SymWTag(btyp^.ref)
- ELSE OPM.SymWTag(Undef);
- IF udpinx < maxUndPtr THEN undPtr[udpinx] := typ; INC(udpinx) ELSE err(224) END
- END ;
- OPM.SymWTag(m)
- | ProcTyp:
- OutStr(btyp); OutPars(typ^.link); OPM.SymWTag(9);
- OPM.SymWTag(btyp^.ref); OPM.SymWTag(m)
- | Comp:
- IF typ^.comp = Array THEN
- OutStr(btyp); OPM.SymWTag(10); OPM.SymWTag(btyp^.ref);
- OPM.SymWTag(m); OPM.SymWLInt(typ^.size)
- ELSIF typ^.comp = DynArr THEN
- OutStr(btyp); OPM.SymWTag(11); OPM.SymWTag(btyp^.ref); OPM.SymWTag(m);
- OPM.SymWLInt(typ^.size); OPM.SymWInt(typ^.offset)
- ELSE (* typ^.comp = Record *)
- IF btyp = NIL THEN r := NoTyp
- ELSE OutStr(btyp); r := btyp^.ref
- END ;
- nofhdfld := 0; OutFlds(typ^.link, 0, TRUE);
- IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(221, typ^.txtpos) END ;
- OPM.SymWTag(12); OPM.SymWTag(r); OPM.SymWTag(m);
- OPM.SymWLInt(typ^.size);
- OPM.SymWInt(typ^.tdadr)
- END
- END ;
- IF typ^.sysflag # 0 THEN OPM.SymWTag(21); OPM.SymWTag(strno); OPM.SymWTag(typ^.sysflag) END ;
- IF (typ^.comp = Record) & (typ^.n > 0) THEN
- OPM.SymWTag(26); OPM.SymWTag(strno); OPM.SymWTag(SHORT(typ^.n))
- END ;
- IF typ^.strobj # NIL THEN
- IF typ^.strobj^.vis # internal THEN OPM.SymWTag(2) ELSE OPM.SymWTag(3) END ;
- OPM.SymWTag(strno); OPM.SymWTag(m); WriteId(typ^.strobj^.name)
- END ;
- typ^.ref := strno; INC(strno);
- IF strno > maxStruct THEN err(228) END ;
- IF typ^.comp = Record THEN OutObjs(typ^.link) END (*bound procedures*)
- END
- END OutStr;
- PROCEDURE OutTyps(obj: Object);
- VAR strobj: Object;
- BEGIN
- IF obj # NIL THEN
- OutTyps(obj^.left);
- IF (obj^.vis # internal) & (obj^.mode = Typ) THEN
- IF obj^.typ^.ref = 0 THEN OutStr(obj^.typ) END ;
- strobj := obj^.typ^.strobj;
- IF (strobj # obj) & (strobj # NIL) THEN
- OPM.SymWTag(2); OPM.SymWTag(obj^.typ^.ref); OPM.SymWTag(0); WriteId(obj^.name)
- END
- END ;
- OutTyps(obj^.right)
- END
- END OutTyps;
- PROCEDURE OutObjs(obj: Object);
- VAR f, m: INTEGER; rval: REAL; ext: ConstExt; typ: Struct; k: LONGINT;
- BEGIN
- IF obj # NIL THEN
- OutObjs(obj^.left);
- IF (obj^.vis # internal) OR (obj^.mode = TProc) THEN
- IF obj^.mode = Var THEN
- OutStr(obj^.typ);
- IF obj^.vis = externalR THEN OPM.SymWTag(23) ELSE OPM.SymWTag(4) END ;
- OPM.SymWTag(obj^.typ^.ref);
- IF OPM.ExpVarAdr THEN OPM.SymWLInt(obj^.adr)
- ELSE OPM.SymWTag(SHORT(obj^.adr))
- END ;
- WriteId(obj^.name)
- ELSIF obj^.mode = Con THEN
- OPM.SymWTag(1); f := obj^.typ^.form; OPM.SymWTag(f);
- CASE f OF
- Byte, Char:
- OPM.SymWCh(CHR(obj^.conval^.intval))
- | Bool, SInt:
- k := obj^.conval^.intval;
- IF k < 0 THEN k := k - 2*OPM.MinSInt END ;
- OPM.SymWCh(CHR(k))
- | Int:
- OPM.SymWInt(obj^.conval^.intval)
- | LInt:
- OPM.SymWLInt(obj^.conval^.intval)
- | Set:
- OPM.SymWSet(obj^.conval^.setval)
- | Real:
- rval := SHORT(obj^.conval^.realval); OPM.SymWReal(rval)
- | LReal:
- OPM.SymWLReal(obj^.conval^.realval)
- | String:
- WriteId(obj^.conval^.ext^)
- | NilTyp:
- ELSE err(127)
- END ;
- WriteId(obj^.name)
- ELSIF obj^.mode = XProc THEN
- OutStr(obj^.typ); OutPars(obj^.link); OPM.SymWTag(6);
- OPM.SymWTag(obj^.typ^.ref); OPM.SymWTag(SHORT(obj^.adr)); WriteId(obj^.name)
- ELSIF obj^.mode = IProc THEN
- OutStr(obj^.typ); OutPars(obj^.link); OPM.SymWTag(5);
- OPM.SymWTag(obj^.typ^.ref); OPM.SymWTag(SHORT(obj^.adr)); WriteId(obj^.name)
- ELSIF obj^.mode = CProc THEN
- OutStr(obj^.typ); OutPars(obj^.link); OPM.SymWTag(7);
- OPM.SymWTag(obj^.typ^.ref); ext := obj^.conval^.ext;
- m := ORD(ext^[0]); f := 1; OPM.SymWCh(CHR(m));
- WHILE f <= m DO OPM.SymWCh(ext^[f]); INC(f) END ;
- WriteId(obj^.name)
- ELSIF obj^.mode = TProc THEN
- typ := obj^.link^.typ; IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ;
- IF (typ^.BaseTyp # NIL) & (obj^.adr DIV 10000H < typ^.BaseTyp^.n) & (obj^.vis = internal) THEN
- OPM.Mark(109, typ^.txtpos)
- (* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *)
- END ;
- IF OPM.ExpHdTProc OR (obj^.vis # internal) THEN
- IF obj^.vis # internal THEN OutStr(obj^.typ); OutPars(obj^.link);
- OPM.SymWTag(25); OPM.SymWTag(obj^.typ^.ref)
- ELSE OPM.SymWTag(27)
- END ;
- OPM.SymWTag(typ^.ref); OPM.SymWTag(SHORT(obj^.adr DIV 10000H));
- OPM.SymWTag(SHORT(obj^.adr MOD 10000H));
- IF obj^.vis # internal THEN WriteId(obj^.name) END
- END
- END
- END ;
- OutObjs(obj^.right)
- END
- END OutObjs;
- PROCEDURE Export*(VAR modName: OPS.Name; VAR newSF: BOOLEAN; VAR key: LONGINT);
- VAR i: INTEGER; done: BOOLEAN;
- oldkey: LONGINT;
- typ: Struct;
- BEGIN
- OPM.NewSym(modName, done);
- IF done THEN strno := firstStr;
- OPM.SymWTag(22); OPM.SymWLInt(key); WriteId(modName); nofExp := 1;
- OutTyps(topScope^.right); OutObjs(topScope^.right); i := 0;
- WHILE i < udpinx DO
- typ := undPtr[i]; undPtr[i] := NIL(*garbage collection*); INC(i); OutStr(typ^.BaseTyp);
- OPM.SymWTag(20); (*fixup*)
- OPM.SymWTag(typ^.ref); OPM.SymWTag(typ^.BaseTyp^.ref)
- END ;
- IF OPM.noerr THEN
- OPM.OldSym(modName, TRUE, done);
- IF done THEN (*compare*)
- IF OPM.EqualSym(oldkey) THEN OPM.DeleteNewSym; newSF := FALSE; key := oldkey
- ELSIF newSF THEN OPM.RegisterNewSym(modName)
- ELSE OPM.DeleteNewSym; err(155)
- END
- ELSE OPM.RegisterNewSym(modName); newSF := TRUE
- END
- ELSE OPM.DeleteNewSym; newSF := FALSE
- END
- ELSE newSF := FALSE
- END
- END Export;
- PROCEDURE InitStruct(VAR typ: Struct; form: SHORTINT);
- BEGIN typ := NewStr(form, Basic); typ^.ref := form; typ^.size := OPM.ByteSize;
- typ^.tdadr := 0; typ^.offset := 0; typ^.strobj := NewObj()
- END InitStruct;
- PROCEDURE EnterBoolConst(name: OPS.Name; value: LONGINT);
- VAR obj: Object;
- BEGIN Insert(name, obj); obj^.conval := NewConst();
- obj^.mode := Con; obj^.typ := booltyp; obj^.conval^.intval := value
- END EnterBoolConst;
- PROCEDURE EnterTyp(name: OPS.Name; form: SHORTINT; size: INTEGER; VAR res: Struct);
- VAR obj: Object; typ: Struct;
- BEGIN Insert(name, obj);
- typ := NewStr(form, Basic); obj^.mode := Typ; obj^.typ := typ; obj^.vis := external;
- typ^.strobj := obj; typ^.size := size; typ^.tdadr := 0; typ^.offset := 0; typ^.ref := form; res := typ
- END EnterTyp;
- PROCEDURE EnterProc(name: OPS.Name; num: INTEGER);
- VAR obj: Object;
- BEGIN Insert(name, obj);
- obj^.mode := SProc; obj^.typ := notyp; obj^.adr := num
- END EnterProc;
- BEGIN
- topScope := NIL; OpenScope(0, NIL); OPM.errpos := 0;
- InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp);
- InitStruct(stringtyp, String); InitStruct(niltyp, NilTyp);
- undftyp^.BaseTyp := undftyp;
- (*initialization of module SYSTEM*)
- EnterTyp("BYTE", Byte, OPM.ByteSize, bytetyp);
- EnterTyp("PTR", Pointer, OPM.PointerSize, sysptrtyp);
- EnterProc("ADR", adrfn);
- EnterProc("CC", ccfn);
- EnterProc("LSH", lshfn);
- EnterProc("ROT", rotfn);
- EnterProc("GET", getfn);
- EnterProc("PUT", putfn);
- EnterProc("GETREG", getrfn);
- EnterProc("PUTREG", putrfn);
- EnterProc("BIT", bitfn);
- EnterProc("VAL", valfn);
- EnterProc("NEW", sysnewfn);
- EnterProc("MOVE", movefn);
- syslink := topScope^.right;
- universe := topScope; topScope^.right := NIL;
- EnterTyp("CHAR", Char, OPM.CharSize, chartyp);
- EnterTyp("SET", Set, OPM.SetSize, settyp);
- EnterTyp("REAL", Real, OPM.RealSize, realtyp);
- EnterTyp("INTEGER", Int, OPM.IntSize, inttyp);
- EnterTyp("LONGINT", LInt, OPM.LIntSize, linttyp);
- EnterTyp("LONGREAL", LReal, OPM.LRealSize, lrltyp);
- EnterTyp("SHORTINT", SInt, OPM.SIntSize, sinttyp);
- EnterTyp("BOOLEAN", Bool, OPM.BoolSize, booltyp);
- EnterBoolConst("FALSE", 0); (* 0 and 1 are compiler internal representation only *)
- EnterBoolConst("TRUE", 1);
- EnterProc("HALT", haltfn);
- EnterProc("NEW", newfn);
- EnterProc("ABS", absfn);
- EnterProc("CAP", capfn);
- EnterProc("ORD", ordfn);
- EnterProc("ENTIER", entierfn);
- EnterProc("ODD", oddfn);
- EnterProc("MIN", minfn);
- EnterProc("MAX", maxfn);
- EnterProc("CHR", chrfn);
- EnterProc("SHORT", shortfn);
- EnterProc("LONG", longfn);
- EnterProc("SIZE", sizefn);
- EnterProc("INC", incfn);
- EnterProc("DEC", decfn);
- EnterProc("INCL", inclfn);
- EnterProc("EXCL", exclfn);
- EnterProc("LEN", lenfn);
- EnterProc("COPY", copyfn);
- EnterProc("ASH", ashfn);
- EnterProc("ASSERT", assertfn)
- END POPT.
-